home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / let.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  7.0 KB  |  173 lines
  1. (herald let (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; Binding macros
  27.  
  28. ;;; Macros for doing bindings of all sorts.
  29.  
  30. (define (valid-spec? spec)
  31.   (and (pair? spec)
  32.        (list? (cdr spec))
  33.        (null? (cddr spec))))  ;(cdr '()) => ()
  34.  
  35. ;++ add the name to LET
  36.  
  37. (define-safe-syntax (let specs . body)
  38.                     ((* valid-spec?) . (* #f))
  39.   (cond ((every? valid-spec? specs)
  40.          `((,(t-syntax 'lambda) ,(map car specs) ,@body)
  41.            ,@(map (lambda (x)
  42.                     (cond ((atom? (cdr x)) 
  43.                            'let-missing-initializer)
  44.                           (else (cadr x))))
  45.                   specs)))
  46.         (else
  47.          (syntax-error "illegal spec~%  ~S" `(let ,specs . ,body)))))
  48.  
  49. (define-safe-syntax (fluid-let specs . body)
  50.                     ((* valid-spec?) . (* #f))
  51.   (cond ((every? valid-spec? specs)
  52.          (let ((temps  (map (lambda (binding)
  53.                               (ignore binding)
  54.                               (generate-symbol 'bind))
  55.                             specs))
  56.                (places (map car  specs))
  57.                (vals   (map cadr specs))
  58.                (handler (generate-symbol 'wind))
  59.                (cell    (generate-symbol 'cell)))
  60.            `((,(t-syntax 'lambda)
  61.               ,temps
  62.               ((,(t-syntax 'lambda)
  63.                 (,handler)
  64.                 (bind-handler ,handler
  65.                               (,(t-syntax 'lambda) () . ,body)
  66.                               ,handler))
  67.                (,(t-syntax 'lambda)
  68.                 ()
  69.                 ,@(map (lambda (place temp)
  70.                          `(,(t-syntax 'let) ((,cell ,place))
  71.                                             (,(t-syntax 'set) ,place ,temp)
  72.                                             (,(t-syntax 'set) ,temp ,cell)))
  73.                        places temps))))
  74.              ,@vals)))
  75.         (else
  76.          (syntax-error "illegal spec~%  ~S" `(bind ,specs ,@body)))))
  77.  
  78. (define-safe-syntax (bind specs . body)
  79.                     ((* valid-spec?) . (* #f))
  80.   (let ((temps  (map (lambda (binding)
  81.                        (ignore binding)
  82.                        (generate-symbol 'bind))
  83.                      specs))
  84.         (places (map car  specs))
  85.         (vals   (map cadr specs))
  86.         (handler (generate-symbol 'wind))
  87.         (cell    (generate-symbol 'cell)))
  88.     (cond ((null? temps)
  89.            `((,(t-syntax 'lambda) () ,@body)))
  90.           (else
  91.            `((,(t-syntax 'lambda)
  92.                ,temps
  93.                ((,(t-syntax 'lambda)
  94.                   (,handler)
  95.                   (bind-handler ,handler
  96.                                 (,(t-syntax 'lambda) () . ,body)
  97.                                 ,handler))
  98.                 (,(t-syntax 'lambda)
  99.                   ()
  100.                   ,@(map (lambda (place temp)
  101.                            `(,(t-syntax 'let) ((,cell ,place))
  102.                               (,(t-syntax 'set) ,place ,temp)
  103.                               (,(t-syntax 'set) ,temp ,cell)))
  104.                          places temps))))
  105.              ,@vals)))))
  106.  
  107. (define-safe-syntax (destructure specs . body)
  108.                     ((* (#f #f)) . (* #f))
  109.   (expand-destructure specs body))
  110.  
  111. ;;; Note that EXPAND-DESTRUCTURE is called from other places.
  112. ;;; Difficult to write this without side-effects.  Try it sometime.
  113.  
  114. (define (expand-destructure specs body)
  115.   (let ((a '()) (b '()))
  116.     (walk (lambda (spec)
  117.             (let ((foo (lambda (vars z val)
  118.                          (cond ((null? vars))
  119.                                ((atom? vars)
  120.                                 (push a `(,vars (,z ,val))))
  121.                                (else
  122.                                 (let ((temp (generate-symbol z)))
  123.                                   (push a `(,temp (,z ,val)))
  124.                                   (push b `(,vars ,temp))))))))  
  125.               (let ((vars (car spec)) (val (cadr spec)))
  126.                 (cond ((atom? vars)
  127.                        ;; No destructuring called for; just do as for LET.
  128.                        (push a spec))
  129.                       ((pair? val)
  130.                        ;; RHS is a call or special form; need to stow value.
  131.                        (let ((temp (generate-symbol 'temp)))
  132.                          (push a `(,temp ,val))
  133.                          (push b `(,vars ,temp))))
  134.                       (else
  135.                        ;; RHS is a variable, LHS is pattern; take apart value.
  136.                        (foo (car vars) 'car val)
  137.                        (foo (cdr vars) 'cdr val))))))
  138.           specs)
  139.     `(,(t-syntax 'let) ,(reverse! a)
  140.        ,(cond ((null? b) (blockify body))
  141.               (else (expand-destructure (reverse! b) body))))))
  142.  
  143. ;(define-syntax (let-destructured . rest)
  144. ;  `(,(t-syntax 'destructure) . ,rest))               ; change later
  145.  
  146. ;;; What about BIND-DESTRUCTURED, LET*-DESTRUCTURED, and BIND*-DESTRUCTURED?
  147.  
  148. (define-safe-syntax (let* specs . rest)
  149.                     ((* valid-spec?) . (* #f))
  150.   (expand-star-macro specs rest (t-syntax 'let)))
  151.  
  152. (define-safe-syntax (destructure* specs . rest)
  153.                     ((* (#f #f)) . (* #f))
  154.   (expand-star-macro specs rest (t-syntax 'destructure)))
  155.  
  156. (define-safe-syntax (bind* specs . rest)
  157.                     ((* valid-spec?) . (* #f))
  158.   (expand-star-macro specs rest (t-syntax 'bind)))
  159.  
  160. (define (expand-star-macro specs rest mac)
  161.   (cond ((null? (cdr specs))
  162.          `(,mac ,specs . ,rest))
  163.         (else `(,mac (,(car specs))
  164.                      ,(expand-star-macro (cdr specs) rest mac)))))
  165.  
  166.  
  167. (define-safe-syntax (receive vars form . body)
  168.                     (formals-list? #f . (* #f))
  169.   `(receive-values (,(t-syntax 'lambda) ,vars ,@body) 
  170.                    (,(t-syntax 'lambda) () ,form)))
  171.  
  172.  
  173.